home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / akcl_lin.z / akcl_lin / c / alloc.c next >
Encoding:
C/C++ Source or Header  |  1993-03-08  |  22.4 KB  |  1,030 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     alloc.c
  9.     IMPLEMENTATION-DEPENDENT
  10. */
  11.  
  12. #include "include.h"
  13.  
  14.  
  15. object Vignore_maximum_pages;
  16.  
  17.  
  18. #include "page.h"
  19.  
  20. #ifdef DEBUG_SBRK
  21. int debug;
  22. char *
  23. sbrk1(n)
  24.      int n;
  25. {char *ans;
  26.  if (debug){
  27.    printf("\n{sbrk(%d)",n);
  28.    fflush(stdout);}
  29.  ans= (char *)sbrk(n);
  30.  if (debug){
  31.    printf("->[0x%x]", ans);
  32.    fflush(stdout);
  33.    printf("core_end=0x%x,sbrk(0)=0x%x}",core_end,sbrk(0));
  34.    fflush(stdout);}
  35.  return ans;
  36. }
  37. #define sbrk sbrk1
  38. #endif /* DEBUG_SBRK */
  39.  
  40. int real_maxpage = MAXPAGE;
  41. int new_holepage;
  42.  
  43. #define    available_pages    \
  44.     (real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
  45.  
  46.  
  47. #ifdef UNIX
  48. extern char *sbrk();
  49. #endif
  50.  
  51. #if defined(BSD) || defined(linux)
  52. #include <sys/time.h>
  53. #include <sys/resource.h>
  54. struct rlimit data_rlimit;
  55. extern char etext;
  56. #endif
  57.  
  58.  
  59. /* If  (n >= 0 ) return pointer to n pages starting at heap end,
  60.    These must come from the hole, so if that is exhausted you have
  61.    to gc and move the hole.
  62.    if  (n < 0) return pointer to n pages starting at heap end,
  63.    but don't worry about the hole.   Basically just make sure
  64.    the space is available from the Operating system.
  65.  */
  66. char *
  67. alloc_page(n)
  68. int n;
  69. {
  70.     char *e;
  71.     int m;
  72.     e = heap_end;
  73.     if (n >= 0) {
  74.         if (n >= holepage) {
  75.             holepage = new_holepage + n;
  76.  
  77.             {int in_sgc=sgc_enabled;
  78.              if (in_sgc) sgc_quit();
  79.             GBC(t_relocatable);
  80.             if (in_sgc)
  81.               {sgc_start();
  82.                /* starting sgc can use up some pages
  83.                   and may move heap end, so start over
  84.                 */
  85.                return alloc_page(n);}
  86.                }
  87.         }
  88.         holepage -= n;
  89.         heap_end += PAGESIZE*n;
  90.         return(e);
  91.     }
  92.      else
  93.        /* n < 0 , then this says ensure there are -n pages
  94.       starting at heap_end, and return pointer to heap_end */
  95.       {
  96.     n = -n;
  97.     m = (core_end - heap_end)/PAGESIZE;
  98.     if (n <= m)
  99.         return(e);
  100.  
  101.     IF_ALLOCATE_ERR error("Can't allocate.  Good-bye!");
  102. #ifdef SGC
  103.     if (sgc_enabled)
  104.       make_writable(page(core_end),page(core_end)+n-m);
  105.  
  106. #endif    
  107.     core_end += PAGESIZE*(n - m);
  108.     return(e);}
  109. }
  110.  
  111. void
  112. add_page_to_freelist(p,tm)
  113.      char *p;
  114.      struct typemanager *tm;
  115. {short t,size;
  116.  int i=tm->tm_nppage,fw;
  117.  int nn;
  118.  object x,f;
  119.  t=tm->tm_type;
  120. #ifdef SGC
  121.  nn=page(p);
  122.  if (sgc_enabled)
  123.    { if (!WRITABLE_PAGE_P(nn)) make_writable(nn,nn+1);}
  124. #endif
  125.  type_map[page(p)]= t;
  126.  size=tm->tm_size;
  127.  f=tm->tm_free;
  128.  x= (object)p;
  129.  x->d.t=t;
  130.  x->d.m=FREE;
  131. #ifdef SGC
  132.  if (sgc_enabled && tm->tm_sgc)
  133.    {x->d.s=SGC_RECENT;
  134.     sgc_type_map[page(x)] = (SGC_PAGE_FLAG | SGC_TEMP_WRITABLE);}
  135.  else x->d.s = SGC_NORMAL;
  136.  
  137.  /* array headers must be always writable, since a write to the
  138.     body does not touch the header.   It may be desirable if there
  139.     are many arrays in a system to make the headers not writable,
  140.     but just SGC_TOUCH the header each time you write to it.   this
  141.     is what is done with t_structure */
  142.   if (t== (tm_of(t_array)->tm_type))
  143.    sgc_type_map[page(x)] |= SGC_PERM_WRITABLE;
  144.    
  145. #endif 
  146.  fw= *(int *)x;
  147.  while (--i >= 0)
  148.    { *(int *)x=fw;
  149.      F_LINK(x)=f;
  150.      f=x;
  151.      x= (object) ((char *)x + size);
  152.    }
  153.  tm->tm_free=f;
  154.  tm->tm_nfree += tm->tm_nppage;
  155.  tm->tm_npage++;
  156. }
  157.  
  158.  
  159.  
  160. object
  161. alloc_object(t)
  162. enum type t;
  163. {
  164.     STATIC object obj;
  165.     STATIC struct typemanager *tm;
  166.     STATIC int i;
  167.     STATIC char *p;
  168.     STATIC object x, f;
  169.  
  170. ONCE_MORE:
  171.     tm = tm_of(t);
  172.  
  173.     if (interrupt_flag) {
  174.         interrupt_flag = FALSE;
  175. #ifdef UNIX
  176.         alarm(0);
  177. #endif
  178.         terminal_interrupt(TRUE);
  179.         goto ONCE_MORE;
  180.     }
  181.     obj = tm->tm_free;
  182.     if (obj == OBJNULL) {
  183.         if (tm->tm_npage >= tm->tm_maxpage)
  184.             goto CALL_GBC;
  185.         if (available_pages < 1) {
  186.             Vignore_maximum_pages->s.s_dbind = Cnil;
  187.             goto CALL_GBC;
  188.         }
  189.         p = alloc_page(1);
  190.         add_page_to_freelist(p,tm);
  191.         obj = tm->tm_free;
  192.         if (tm->tm_npage >= tm->tm_maxpage)
  193.             goto CALL_GBC;
  194.     }
  195.     tm->tm_free = ((struct freelist *)obj)->f_link;
  196.     --(tm->tm_nfree);
  197.     (tm->tm_nused)++;
  198.     obj->d.t = (short)t;
  199.     obj->d.m = FALSE;
  200.     return(obj);
  201. #define TOTAL_THIS_TYPE(tm) \
  202.     (tm->tm_nppage * (sgc_enabled ? sgc_count_type(tm->tm_type) : tm->tm_npage))
  203. CALL_GBC:
  204.     GBC(tm->tm_type);
  205.     if (tm->tm_nfree == 0 ||
  206.         (float)tm->tm_nfree * 10.0 < (float) TOTAL_THIS_TYPE(tm))
  207.         goto EXHAUSTED;
  208.     goto ONCE_MORE;
  209.  
  210. EXHAUSTED:
  211.     if (symbol_value(Vignore_maximum_pages) != Cnil) {
  212.         if (tm->tm_maxpage/2 <= 0)
  213.             tm->tm_maxpage += 1;
  214.         else
  215.             tm->tm_maxpage += tm->tm_maxpage/2;
  216.         goto ONCE_MORE;
  217.     }
  218.     GBC_enable = FALSE;
  219.     vs_push(make_simple_string(tm_table[(int)t].tm_name+1));
  220.     vs_push(make_fixnum(tm->tm_npage));
  221.     GBC_enable = TRUE;
  222.     CEerror("The storage for ~A is exhausted.~%\
  223. Currently, ~D pages are allocated.~%\
  224. Use ALLOCATE to expand the space.",
  225.         "Continues execution.",
  226.         2, vs_top[-2], vs_top[-1]);
  227.     vs_pop;
  228.     vs_pop;
  229.     goto ONCE_MORE;
  230. }
  231.  
  232. grow_linear(old,fract,grow_min,grow_max)
  233.      int old,grow_min,grow_max,fract;
  234. {int delt;
  235.  if(fract==0) fract=50;
  236.  if(grow_min==0) grow_min=1;
  237.  if(grow_max==0) grow_max=1000;
  238.  delt=(old*fract)/100;
  239.  delt= (delt < grow_min ? grow_min:
  240.     delt > grow_max ? grow_max:
  241.     delt);
  242.  return old + delt;}
  243.  
  244. object
  245. make_cons(a, d)
  246. object a, d;
  247. {
  248.     STATIC object obj;
  249.     STATIC int i;
  250.     STATIC char *p;
  251.     STATIC object x, f;
  252.     struct typemanager *tm=(&tm_table[(int)t_cons]);
  253. /* #define    tm    (&tm_table[(int)t_cons])*/
  254.  
  255. ONCE_MORE:
  256.     if (interrupt_flag) {
  257.         interrupt_flag = FALSE;
  258. #ifdef UNIX
  259.         alarm(0);
  260. #endif
  261.         terminal_interrupt(TRUE);
  262.         goto ONCE_MORE;
  263.     }
  264.     obj = tm->tm_free;
  265.     if (obj == OBJNULL) {
  266.         if (tm->tm_npage >= tm->tm_maxpage)
  267.             goto CALL_GBC;
  268.         if (available_pages < 1) {
  269.             Vignore_maximum_pages->s.s_dbind = Cnil;
  270.             goto CALL_GBC;
  271.         }
  272.         p = alloc_page(1);
  273.         add_page_to_freelist(p,tm);
  274.         obj = tm->tm_free ;
  275.         if (tm->tm_npage >= tm->tm_maxpage)
  276.             goto CALL_GBC;
  277.     }
  278.     tm->tm_free = ((struct freelist *)obj)->f_link;
  279.     --(tm->tm_nfree);
  280.     (tm->tm_nused)++;
  281.     obj->c.t = (short)t_cons;
  282.     obj->c.m = FALSE;
  283.     obj->c.c_car = a;
  284.     obj->c.c_cdr = d;
  285.     return(obj);
  286.  
  287. CALL_GBC:
  288.     GBC(t_cons);
  289.     if (tm->tm_nfree == 0 ||
  290.         (float)tm->tm_nfree * 10.0 < (float) TOTAL_THIS_TYPE(tm))
  291.         goto EXHAUSTED;
  292.     goto ONCE_MORE;
  293.  
  294. EXHAUSTED:
  295.     if (symbol_value(Vignore_maximum_pages) != Cnil) {
  296.       tm->tm_maxpage =
  297.         grow_linear(tm->tm_maxpage,tm->tm_growth_percent,
  298.             tm->tm_min_grow,tm->tm_max_grow);
  299.         goto ONCE_MORE;
  300.     }
  301.     GBC_enable = FALSE;
  302.     vs_push(make_fixnum(tm->tm_npage));
  303.     GBC_enable = TRUE;
  304.     CEerror("The storage for CONS is exhausted.~%\
  305. Currently, ~D pages are allocated.~%\
  306. Use ALLOCATE to expand the space.",
  307.         "Continues execution.",
  308.         1, vs_top[-1]);
  309.     vs_pop;
  310.     goto ONCE_MORE;
  311. #undef    tm
  312. }
  313.  
  314.  
  315. object on_stack_cons(x,y)
  316.      object x,y;
  317. {object p = (object) alloca_val;
  318.  p->c.t= (short)t_cons;
  319.  p->c.m=FALSE;
  320.  p->c.c_car=x;
  321.  p->c.c_cdr=y;
  322.  return p;
  323. }
  324.  
  325.  
  326.  
  327.  
  328. #define    round_up(n)    (((n) + 03) & ~03)
  329.  
  330. char *
  331. alloc_contblock(n)
  332. int n;
  333. {
  334.     STATIC char *p;
  335.     STATIC struct contblock **cbpp;
  336.     STATIC int i;
  337.     STATIC int m;
  338.     STATIC bool g;
  339.     bool gg;
  340.  
  341. /*
  342.     printf("allocating %d-byte contiguous block...\n", n);
  343. */
  344.  
  345.     g = FALSE;
  346.     n = round_up(n);
  347.  
  348. ONCE_MORE:
  349.     if (interrupt_flag) {
  350.         interrupt_flag = FALSE;
  351.         gg = g;
  352.         terminal_interrupt(TRUE);
  353.         g = gg;
  354.         goto ONCE_MORE;
  355.     }
  356.     for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
  357.         if ((*cbpp)->cb_size >= n) {
  358.             p = (char *)(*cbpp);
  359.             i = (*cbpp)->cb_size - n;
  360.             *cbpp = (*cbpp)->cb_link;
  361.             --ncb;
  362.             insert_contblock(p+n, i);
  363.             return(p);
  364.         }
  365.     m = (n + PAGESIZE - 1)/PAGESIZE;
  366.     if (ncbpage + m > maxcbpage || available_pages < m) {
  367.         if (available_pages < m)
  368.             Vignore_maximum_pages->s.s_dbind = Cnil;
  369.         if (!g) {
  370.             GBC(t_contiguous);
  371.             g = TRUE;
  372.             goto ONCE_MORE;
  373.         }
  374.         if (symbol_value(Vignore_maximum_pages) != Cnil)
  375.           {struct typemanager *tm = &tm_table[(int)t_contiguous];
  376.            maxcbpage=grow_linear(maxcbpage,tm->tm_growth_percent,
  377.                   tm->tm_min_grow, tm->tm_max_grow);
  378.             g = FALSE;
  379.             goto ONCE_MORE;
  380.         }
  381.         vs_push(make_fixnum(ncbpage));
  382.         CEerror("Contiguous blocks exhausted.~%\
  383. Currently, ~D pages are allocated.~%\
  384. Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
  385.             "Continues execution.", 1, vs_head);
  386.         vs_pop;
  387.         g = FALSE;
  388.         goto ONCE_MORE;
  389.     }
  390.  
  391.     p = alloc_page(m);
  392.  
  393.     for (i = 0;  i < m;  i++)
  394.         type_map[page(p) + i] = (char)t_contiguous;
  395.     ncbpage += m;
  396.     insert_contblock(p+n, PAGESIZE*m - n);
  397.     return(p);
  398. }
  399.  
  400. insert_contblock(p, s)
  401. char *p;
  402. int s;
  403. {
  404.     struct contblock **cbpp, *cbp;
  405.  
  406.     if (s < CBMINSIZE)
  407.         return;
  408.     ncb++;
  409.     cbp = (struct contblock *)p;
  410.     cbp->cb_size = s;
  411.     for (cbpp = &cb_pointer;  *cbpp;  cbpp = &((*cbpp)->cb_link))
  412.         if ((*cbpp)->cb_size >= s) {
  413.             cbp->cb_link = *cbpp;
  414.             *cbpp = cbp;
  415.             return;
  416.         }
  417.     cbp->cb_link = NULL;
  418.     *cbpp = cbp;
  419. }
  420.  
  421. char *
  422. alloc_relblock(n)
  423. int n;
  424. {
  425.     STATIC char *p;
  426.     STATIC bool g;
  427.     bool gg;
  428.     int i;
  429.  
  430. /*
  431.     printf("allocating %d-byte relocatable block...\n", n);
  432. */
  433.  
  434.     g = FALSE;
  435.     n = round_up(n);
  436.  
  437. ONCE_MORE:
  438.     if (interrupt_flag) {
  439.         interrupt_flag = FALSE;
  440.         gg = g;
  441.         terminal_interrupt(TRUE);
  442.         g = gg;
  443.         goto ONCE_MORE;
  444.     }
  445.     if (rb_limit - rb_pointer < n) {
  446.         if (!g) {
  447.             GBC(t_relocatable);
  448.             g = TRUE;
  449.             { float f1 = (float)(rb_limit - rb_pointer),
  450.                 f2 = (float)(rb_limit - rb_start);
  451.  
  452.                 if (f1 * 10.0 < f2) 
  453.                 ;
  454.             else
  455.                 goto ONCE_MORE;
  456.             }
  457.         }
  458.         if (symbol_value(Vignore_maximum_pages) != Cnil)
  459.           {struct typemanager *tm = &tm_table[(int)t_relocatable];
  460.            nrbpage=grow_linear(i=nrbpage,tm->tm_growth_percent,
  461.                   tm->tm_min_grow, tm->tm_max_grow);
  462.            if (available_pages < 0)
  463.              nrbpage = i;
  464.            else {
  465.               rb_end +=  (PAGESIZE* (nrbpage -i));
  466.               rb_limit = rb_end - 2*RB_GETA;
  467.               if (page(rb_end) - page(heap_end) !=
  468.                   holepage + nrbpage)
  469.                 FEerror("bad rb_end");
  470.               alloc_page(-( nrbpage + holepage));
  471.               g = FALSE;
  472.               goto ONCE_MORE;
  473.             }
  474.         }
  475.         if (rb_limit > rb_end - 2*RB_GETA)
  476.             error("relocatable blocks exhausted");
  477.         rb_limit += RB_GETA;
  478.         vs_push(make_fixnum(nrbpage));
  479.         CEerror("Relocatable blocks exhausted.~%\
  480. Currently, ~D pages are allocated.~%\
  481. Use ALLOCATE-RELOCATABLE-PAGES to expand the space.",
  482.             "Continues execution.", 1, vs_head);
  483.         vs_pop;
  484.         g = FALSE;
  485.         goto ONCE_MORE;
  486.     }
  487.     p = rb_pointer;
  488.     rb_pointer += n;
  489.     return(p);
  490. }
  491.  
  492. init_tm(t, name, elsize, nelts,sgc)
  493. enum type t;
  494. char name[];
  495. int elsize, nelts;
  496. {
  497.     int i, j;
  498.     int maxpage;
  499.     /* round up to next number of pages */
  500.     maxpage = (((nelts * elsize) + PAGESIZE -1)/PAGESIZE);
  501.     tm_table[(int)t].tm_name = name;
  502.     for (j = -1, i = 0;  i < (int)t_end;  i++)
  503.         if (tm_table[i].tm_size != 0 &&
  504.             tm_table[i].tm_size >= elsize &&
  505.             (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size))
  506.             j = i;
  507.     if (j >= 0) {
  508.         tm_table[(int)t].tm_type = (enum type)j;
  509.         tm_table[j].tm_maxpage += maxpage;
  510. #ifdef SGC        
  511.         tm_table[j].tm_sgc += sgc;
  512. #endif
  513.         return;
  514.     }
  515.     tm_table[(int)t].tm_type = t;
  516.     tm_table[(int)t].tm_size = round_up(elsize);
  517.     tm_table[(int)t].tm_nppage = PAGESIZE/round_up(elsize);
  518.     tm_table[(int)t].tm_free = OBJNULL;
  519.     tm_table[(int)t].tm_nfree = 0;
  520.     tm_table[(int)t].tm_nused = 0;
  521.     tm_table[(int)t].tm_npage = 0;
  522.     tm_table[(int)t].tm_maxpage = maxpage;
  523.     tm_table[(int)t].tm_gbccount = 0;
  524. #ifdef SGC    
  525.     tm_table[(int)t].tm_sgc = sgc;
  526.     tm_table[(int)t].tm_sgc_max = 3000;
  527.     tm_table[(int)t].tm_sgc_minfree = (int)
  528.       (0.4 * tm_table[(int)t].tm_nppage);
  529. #endif
  530.  
  531. }
  532.  
  533. set_maxpage()
  534. {
  535.   /* This is run in init.  Various initializations including getting
  536.      maxpage are here */ 
  537. #ifdef SGC
  538.   page_multiple=getpagesize()/PAGESIZE;
  539.   if (page_multiple==0) error("PAGESIZE must be factor of getpagesize()");
  540.   if (sgc_enabled)
  541.     {memory_protect(1);}
  542.   if (~(-MAXPAGE) != MAXPAGE-1) error("MAXPAGE must be power of 2");
  543.   if (core_end)
  544.      bzero(&sgc_type_map[ page(core_end)],MAXPAGE- page(core_end));
  545. #else
  546.   page_multiple=1;
  547. #endif
  548.   
  549. SET_REAL_MAXPAGE;
  550.  
  551.       }
  552.  
  553.  
  554.  
  555.  
  556.  
  557. init_alloc()
  558. {
  559.     int i, j;
  560.     struct typemanager *tm;
  561.     char *p, *q;
  562.     enum type t;
  563.     int c;
  564.     static initialized;
  565.     if (initialized) return;
  566.     initialized=1;
  567.     
  568.     
  569. #ifdef UNIX
  570. #ifndef DGUX
  571.     {
  572.         extern object malloc_list;
  573.         malloc_list = Cnil;
  574.         enter_mark_origin(&malloc_list);
  575.     }
  576. #endif
  577. #endif    
  578.     holepage = INIT_HOLEPAGE;
  579.     new_holepage = HOLEPAGE;
  580.     nrbpage = INIT_NRBPAGE;
  581.  
  582.     set_maxpage();
  583.  
  584.  
  585.     INIT_ALLOC;
  586.     
  587.  
  588.     alloc_page(-(holepage + nrbpage));
  589.     rb_start = rb_pointer = heap_end + PAGESIZE*holepage;
  590.     rb_end = rb_start + PAGESIZE*nrbpage;
  591.     rb_limit = rb_end - 2*RB_GETA;
  592. #ifdef SGC    
  593.     tm_table[(int)t_relocatable].tm_sgc = 50;
  594. #endif
  595.     
  596.     for (i = 0;  i < MAXPAGE;  i++)
  597.         type_map[i] = (char)t_other;
  598.  
  599.     init_tm(t_fixnum, "NFIXNUM",
  600.         sizeof(struct fixnum_struct), 8192,20);
  601.     init_tm(t_cons, ".CONS", sizeof(struct cons), 65536 ,50 );
  602.     init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure), 5461,0 );
  603.     init_tm(t_cfun, "fCFUN", sizeof(struct cfun), 4096,0  );
  604.     init_tm(t_sfun, "gSFUN", sizeof(struct sfun),409,0 );
  605.     init_tm(t_string, "\"STRING", sizeof(struct string), 5461,1  );
  606.     init_tm(t_array, "aARRAY", sizeof(struct array), 4681,1 );
  607.     init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol), 3640,1 );
  608.     init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 2730,0 );
  609.     init_tm(t_ratio, "RRATIONAL", sizeof(struct ratio), 170,0 );
  610.     init_tm(t_shortfloat, "FSHORT-FLOAT",
  611.         sizeof(struct shortfloat_struct), 256 ,0);
  612.     init_tm(t_longfloat, "LLONG-FLOAT",
  613.         sizeof(struct longfloat_struct), 170 ,0);
  614.     init_tm(t_complex, "CCOMPLEX", sizeof(struct complex), 170 ,0);
  615.     init_tm(t_character,"#CHARACTER",sizeof(struct character), 256 ,0);
  616.     init_tm(t_package, ":PACKAGE", sizeof(struct package), 2*PAGESIZE / sizeof(struct package),0);
  617.     init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct hashtable), 78,0 );
  618.     init_tm(t_vector, "vVECTOR", sizeof(struct vector), 146 ,0);
  619.     init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct bitvector), 73 ,0);
  620.     init_tm(t_stream, "sSTREAM", sizeof(struct stream), 78 ,0);
  621.     init_tm(t_random, "$RANDOM-STATE", sizeof(struct random), 256 ,0);
  622.     init_tm(t_readtable, "rREADTABLE", sizeof(struct readtable), 256 ,0);
  623.     init_tm(t_pathname, "pPATHNAME", sizeof(struct pathname), 73 ,0);
  624.     init_tm(t_cclosure, "cCCLOSURE", sizeof(struct cclosure), 85 ,0);
  625.     init_tm(t_vfun, "VVFUN", sizeof(struct vfun), 102 ,0);
  626.     init_tm(t_gfun, "gGFUN", sizeof(struct sfun), 0 ,0);
  627.     init_tm(t_cfdata, "cCFDATA", sizeof(struct cfdata), 102 ,0);
  628.     init_tm(t_spice, "!SPICE", sizeof(struct spice), 4096 ,0);
  629.     init_tm(t_fat_string, "FFAT-STRING", sizeof(struct fat_string), 102
  630.         ,0);
  631.     init_tm(t_relocatable, "%RELOCATABLE-BLOCKS", 1000,0,20);
  632.     init_tm(t_contiguous, "_CONTIGUOUS-BLOCKS", 1001,0,20);
  633.  
  634.  
  635.     ncb = 0;
  636.     ncbpage = 0;
  637.     maxcbpage = 512;
  638.     
  639. }
  640.  
  641.  
  642. cant_get_a_type()
  643. {
  644.     FEerror("Can't get a type.", 0);
  645. }
  646.  
  647. siLallocate()
  648. {
  649.     struct typemanager *tm;
  650.     int c, i;
  651.     char *p, *pp;
  652.     object f, x;
  653.     int t;
  654.  
  655.     if (vs_top - vs_base < 2)
  656.         too_few_arguments();
  657.     if (vs_top - vs_base > 3)
  658.       too_many_arguments();
  659.     t= t_from_type(vs_base[0]);
  660.     if (type_of(vs_base[1]) != t_fixnum ||
  661.         (i = fix(vs_base[1])) < 0)
  662.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[1]);
  663.     tm = tm_of(t);
  664.     if (tm->tm_npage > i) {i=tm->tm_npage;}
  665.     tm->tm_maxpage = i;
  666.     if (vs_top - vs_base == 3 && vs_base[2] != Cnil &&
  667.         tm->tm_maxpage > tm->tm_npage)
  668.       goto ALLOCATE;
  669.     vs_top = vs_base;
  670.     vs_push(Ct);
  671.     return;
  672.  
  673. ALLOCATE:
  674.     if (available_pages < tm->tm_maxpage - tm->tm_npage ||
  675.         (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) {
  676.     vs_push(make_simple_string(tm->tm_name+1));
  677.     FEerror("Can't allocate ~D pages for ~A.", 2, vs_base[1], vs_top[-1]);
  678.     }
  679.     for (;  tm->tm_npage < tm->tm_maxpage;  pp += PAGESIZE)
  680.       add_page_to_freelist(pp,tm);
  681.     vs_top = vs_base;
  682.     vs_push(Ct);
  683. }
  684.  
  685. t_from_type(type)
  686.      object type;
  687. {object typ= coerce_to_string(type);
  688.  object c = aref1(typ,0);
  689.  int i;
  690.  for (i= (int)t_start ; i < (int)t_contiguous ; i++)
  691.    {struct typemanager *tm = &tm_table[i];
  692.    if(tm->tm_name &&
  693.       0==strncmp((tm->tm_name)+1,typ->st.st_self,typ->st.st_fillp)
  694.       )
  695.      return i;}
  696.  FEerror("Unrecognized type");
  697. }
  698. /* When sgc is enabled the TYPE should have at least MIN pages of sgc type,
  699.    and at most MAX of them.   Each page should be FREE_PERCENT free
  700.    when the sgc is turned on.  FREE_PERCENT is an integer between 0 and 100. 
  701.    */
  702.    
  703. object
  704. siSallocate_sgc(type,min,max,free_percent)
  705.      object type;
  706.      int min,max,free_percent;
  707. {int m,t=t_from_type(type);
  708.  struct typemanager *tm;
  709.  object res;
  710.  tm=tm_of(t);
  711.   res= list(3,make_fixnum(tm->tm_sgc),
  712.        make_fixnum(tm->tm_sgc_max),
  713.        make_fixnum((100*tm->tm_sgc_minfree)/tm->tm_nppage));
  714.  
  715.  if(min<0 || max< min || min > 3000 || free_percent < 0 || free_percent > 100)
  716.     goto END;
  717.  tm->tm_sgc_max=max;
  718.  tm->tm_sgc=min;
  719.  tm->tm_sgc_minfree= (tm->tm_nppage *free_percent) /100;
  720.  END:
  721.  return res;
  722. }
  723.  
  724. /* Growth of TYPE will be by at least MIN pages and at most MAX pages.
  725.    It will try to grow PERCENT of the current pages.
  726.    */
  727. object
  728. siSallocate_growth(type,min,max,percent)
  729. int min,max,percent;
  730. object type;
  731. {int  t=t_from_type(type);
  732.  struct typemanager *tm=tm_of(t);
  733.  object res;
  734.  res= list(3,make_fixnum(tm->tm_min_grow),
  735.        make_fixnum(tm->tm_max_grow),
  736.        make_fixnum(tm->tm_growth_percent));
  737.  
  738.  if(min<0 || max< min || min > 3000 || percent < 0 || percent > 500)
  739.     goto END;
  740.  tm->tm_max_grow=max;
  741.  tm->tm_min_grow=min;
  742.  tm->tm_growth_percent= percent;
  743.  END:
  744.  return res;
  745. }
  746.  
  747.   
  748.  
  749. siLallocated_pages()
  750. {
  751.     struct typemanager *tm;
  752.     int c;
  753.  
  754.     check_arg(1);
  755.     {int t=t_from_type(vs_base[0]);
  756.      vs_base[0]=make_fixnum(tm_of(t)->tm_npage);}
  757.       }
  758.  
  759.  
  760. siLmaxpage()
  761. {
  762.     struct typemanager *tm;
  763.     int c;
  764.  
  765.     check_arg(1);
  766.     {int t=t_from_type(vs_base[0]);
  767.      vs_base[0]=make_fixnum(tm_of(t)->tm_npage);}
  768.       }
  769.  
  770.  
  771. siLalloc_contpage()
  772. {
  773.     int i, m;
  774.     char *p;
  775.  
  776.     if (vs_top - vs_base < 1)
  777.         too_few_arguments();
  778.     if (vs_top - vs_base > 2)
  779.         too_many_arguments();
  780.     if (type_of(vs_base[0]) != t_fixnum ||
  781.         (i = fix(vs_base[0])) < 0)
  782.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[0]);
  783.     if (ncbpage > i)
  784.       { printf("Allocate contiguous %d: %d already there pages",i,ncbpage);
  785.         i=ncbpage;}
  786.     maxcbpage = i;
  787.     if (vs_top - vs_base < 2 || vs_base[1] == Cnil) {
  788.         vs_top = vs_base;
  789.         vs_push(Ct);
  790.         return;
  791.     }
  792.     m = maxcbpage - ncbpage;
  793.     if (available_pages < m || (p = alloc_page(m)) == NULL)
  794.         FEerror("Can't allocate ~D pages for contiguous blocks.",
  795.             1, vs_base[0]);
  796.     for (i = 0;  i < m;  i++)
  797.         type_map[page(p + PAGESIZE*i)] = (char)t_contiguous;
  798.     ncbpage += m;
  799.     insert_contblock(p, PAGESIZE*m);
  800.     vs_top = vs_base;
  801.     vs_push(Ct);
  802. }
  803.  
  804. siLncbpage()
  805. {
  806.     check_arg(0);
  807.     vs_push(make_fixnum(ncbpage));
  808. }
  809.  
  810. siLmaxcbpage()
  811. {
  812.     check_arg(0);
  813.     vs_push(make_fixnum(maxcbpage));
  814. }
  815.  
  816. siLalloc_relpage()
  817. {
  818.     int i;
  819.     char *p;
  820.  
  821.     if (vs_top - vs_base < 1)
  822.         too_few_arguments();
  823.     if (vs_top - vs_base > 2)
  824.         too_many_arguments();
  825.     if (type_of(vs_base[0]) != t_fixnum ||
  826.         (i = fix(vs_base[0])) < 0)
  827.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[0]);
  828.     if (nrbpage > i && rb_pointer >= rb_start + PAGESIZE*i - 2*RB_GETA
  829.      || 2*i > real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)
  830.         FEerror("Can't set the limit for relocatable blocks to ~D.",
  831.             1, vs_base[0]);
  832.     rb_end += (i-nrbpage)*PAGESIZE;
  833.     nrbpage = i;
  834.     rb_limit = rb_end - 2*RB_GETA;
  835.     alloc_page(-(holepage + nrbpage));
  836.     vs_top = vs_base;
  837.     vs_push(Ct);
  838. }
  839.  
  840. siLnrbpage()
  841. {
  842.     check_arg(0);
  843.     vs_push(make_fixnum(nrbpage));
  844. }
  845.  
  846. siLget_hole_size()
  847. {
  848.     check_arg(0);
  849.     vs_push(make_fixnum(new_holepage));
  850. }
  851.  
  852. siLset_hole_size()
  853. {
  854.     int i;
  855.  
  856.     check_arg(1);
  857.     i = fixint(vs_base[0]);
  858.     if (i < 1 ||
  859.         i > real_maxpage - page(heap_end) - 2*nrbpage - real_maxpage/32)
  860.         FEerror("Illegal value for the hole size.", 0);
  861.     new_holepage = i;
  862. }
  863.  
  864. init_alloc_function()
  865. {
  866.     make_si_function("ALLOCATE", siLallocate);
  867.     make_si_function("ALLOCATED-PAGES", siLallocated_pages);
  868.     make_si_function("MAXIMUM-ALLOCATABLE-PAGES", siLmaxpage);
  869.     make_si_function("ALLOCATE-CONTIGUOUS-PAGES", siLalloc_contpage);
  870.     make_si_function("ALLOCATED-CONTIGUOUS-PAGES", siLncbpage);
  871.     make_si_function("MAXIMUM-CONTIGUOUS-PAGES", siLmaxcbpage);
  872.     make_si_function("ALLOCATE-RELOCATABLE-PAGES", siLalloc_relpage);
  873.     make_si_function("ALLOCATED-RELOCATABLE-PAGES", siLnrbpage);
  874.     make_si_function("GET-HOLE-SIZE", siLget_hole_size);
  875.     make_si_function("SET-HOLE-SIZE", siLset_hole_size);
  876.     make_si_sfun("ALLOCATE-SGC",siSallocate_sgc,
  877.              4 | ARGTYPE(0,f_object) | ARGTYPE(1,f_fixnum) |
  878.              ARGTYPE(2,f_fixnum) | ARGTYPE(3,f_fixnum)
  879.              | RESTYPE(f_object));
  880.  
  881.  
  882.     make_si_sfun("ALLOCATE-GROWTH",siSallocate_growth,
  883.              4 | ARGTYPE(0,f_object) | ARGTYPE(1,f_fixnum) |
  884.              ARGTYPE(2,f_fixnum) | ARGTYPE(3,f_fixnum)
  885.              | RESTYPE(f_object));
  886.     Vignore_maximum_pages
  887.     = make_special("*IGNORE-MAXIMUM-PAGES*", Ct);
  888.  
  889. }
  890.  
  891. #ifdef UNIX
  892. #ifndef DGUX
  893.  
  894. /*
  895.     UNIX malloc simulator.
  896.  
  897.     Used by
  898.         getwd, popen, etc.
  899. */
  900.  
  901. object malloc_list;
  902.  
  903. /*  If this is defined, substitute the fast gnu malloc for the slower
  904.     version below.   If you have many calls to malloc this is worth
  905.     your while.   I have only tested it slightly under 4.3Bsd.   There
  906.     the difference in a test run with 120K mallocs and frees,
  907.     was 29 seconds to 1.9 seconds */
  908.     
  909. #ifdef GNU_MALLOC
  910. #include "malloc.c"
  911. #else
  912.  
  913. char *
  914. malloc(size)
  915. int size;
  916. {
  917.     object x;
  918.  
  919.     if (GBC_enable==0 && initflag ==0)
  920.       { init_alloc();}
  921.       
  922.  
  923.     x = alloc_simple_string(size);
  924.  
  925.     x->st.st_self = alloc_contblock(size);
  926. #ifdef SGC
  927.     perm_writable(x->st.st_self,size);
  928. #endif
  929.     malloc_list = make_cons(x, malloc_list);
  930.  
  931.     return(x->st.st_self);
  932. }
  933.  
  934.  
  935. void
  936. free(ptr)
  937. #ifndef NO_VOID_STAR
  938. void *
  939. #else
  940. char *
  941. #endif  
  942.   ptr;
  943. {
  944.     object *p;
  945.  
  946.     for (p = &malloc_list; *p && !endp(*p);  p = &((*p)->c.c_cdr))
  947.         if ((*p)->c.c_car->st.st_self == ptr) {
  948.             insert_contblock((*p)->c.c_car->st.st_self,
  949.                      (*p)->c.c_car->st.st_dim);
  950.             (*p)->c.c_car->st.st_self = NULL;
  951.             *p = (*p)->c.c_cdr;
  952.             return ;
  953.         }
  954. #ifdef NOFREE_ERR
  955.     return ;
  956. #else    
  957.     FEerror("free(3) error.",0);
  958.     return;
  959. #endif    
  960. }
  961.  
  962. char *
  963. realloc(ptr, size)
  964. char *ptr;
  965. int size;
  966. {
  967.     object x;
  968.     int i, j;
  969.  
  970.     for (x = malloc_list;  !endp(x);  x = x->c.c_cdr)
  971.         if (x->c.c_car->st.st_self == ptr) {
  972.             x = x->c.c_car;
  973.             if (x->st.st_dim >= size) {
  974.                 x->st.st_fillp = size;
  975.                 return(ptr);
  976.             } else {
  977.                 j = x->st.st_dim;
  978.                 x->st.st_self = alloc_contblock(size);
  979.                 x->st.st_fillp = x->st.st_dim = size;
  980.                 for (i = 0;  i < size;  i++)
  981.                     x->st.st_self[i] = ptr[i];
  982.                 insert_contblock(ptr, j);
  983.                 return(x->st.st_self);
  984.             }
  985.         }
  986.     FEerror("realloc(3) error.", 0);
  987. }
  988.  
  989. #endif /* gnumalloc */
  990. char *
  991. calloc(nelem, elsize)
  992. int nelem, elsize;
  993. {
  994.     char *ptr;
  995.     int i;
  996.  
  997.     ptr = malloc(i = nelem*elsize);
  998.     while (--i >= 0)
  999.         ptr[i] = 0;
  1000.     return(ptr);
  1001. }
  1002.  
  1003. cfree(ptr)
  1004. char *ptr;
  1005. {
  1006.     free(ptr);
  1007.  
  1008. }
  1009. #endif
  1010. #endif
  1011.  
  1012.  
  1013. #ifndef GNUMALLOC
  1014. char *
  1015. memalign(align,size)
  1016.      int align,size;
  1017. { object x = alloc_simple_string(size);
  1018.   x->st.st_self = ALLOC_ALIGNED(alloc_contblock,size,align);
  1019.   malloc_list = make_cons(x, malloc_list);
  1020.   return x->st.st_self;
  1021. }
  1022. #ifdef WANT_VALLOC
  1023. char *
  1024. valloc(size)
  1025. int size;     
  1026. { return memalign(getpagesize(),size);}
  1027. #endif
  1028.  
  1029. #endif
  1030.